home *** CD-ROM | disk | FTP | other *** search
Text File | 1993-02-12 | 85.7 KB | 2,193 lines |
- *-- PROGRAM.....: PROC.PRG
- *-------------------------------------------------------------------------------
- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
- *-- Date........: 11/10/1992
- *-- Version.....: 2.92 -- See WHATS.NEW and README.TXT files (both ASCII),
- *-- both files uploaded with this file in one
- *-- zipped file.
- *-- Notes.......: This procedure file is part of the new and improved set of
- *-- files, re-designed for dBASE IV, 1.5. The complete set is
- *-- contained in the file: LIB192.ZIP. Please read README.TXT
- *-- for all instructions.
- *===============================================================================
-
- *===============================================================================
- * MESSAGE/SCREEN PROCESSING ROUTINES -- includes message boxes, shadowing,
- * and centering of text ... Anything not here is in the library file:
- * SCREEN.PRG.
- *===============================================================================
-
- PROCEDURE PrintErr
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 05/24/1991
- *-- Notes.......: Used to display a printer error for STAND-ALONE
- *-- systems. (The dBASE function PRINTSTATUS() doesn't work
- *-- well on a Network with Print Spoolers ...)
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- CENTER Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: do printerr
- *-- Example.....: do setprint && if it hasn't been done
- *-- if .not. printstatus()
- *-- DO PRINTERR
- *-- endif
- *-- * or
- *-- do while .not. printstatus() && my preference ... loop!
- *-- DO PRINTERR
- *-- enddo
- *-- Returns.....: None
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private cColor, cDummy, cCursor
-
- if iscolor() && if we're using a color monitor, use yellow on red
- cColor = "RG+/R,RG+/R,RG+/R"
- else && otherwise, use black on white
- cColor = "N/W,N/W,N/W"
- endif
-
- activate screen
- define window wPErr from 7,15 to 16,57 double color &cColor
- save screen to sPErr && store current screen
- do shadow with 7,15,16,57 && shadow box!
- activate window wPErr && here we go ..
-
- cCursor=set("CURSOR") && save cursor setting
- set cursor off && turn cursor off
- && display message
- do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***"
- do center with 2,40,""," The printer is not ready. Please check:"
- do center with 3,40,"","1) that the printer is ON, "
- do center with 4,40,"","2) that the printer is ONLINE, and"
- do center with 5,40,"","3) that the printer has paper. "
- do center with 7,40,"","Press any key to continue . . ."
-
- cDummy=inkey(0) && wait for user to press a key ...
- set cursor &cCursor && set cursor to original setting ...
-
- deactivate window wPErr && cleanup
- release window wPErr
- restore screen from sPErr
- release screen sPErr
-
- RETURN
- *-- EoP: PrintErr
-
- PROCEDURE Open_Screen
- *-------------------------------------------------------------------------------
- *-- Programmer..: Rick Price (HAMMETT)
- *-- Date........: 05/24/1991
- *-- Notes.......: Used to give a texture to the background of the screen
- *-- I got this from Rick when he uploaded it as part of his
- *-- original entry to a Color Contest on the ATBBS. It is
- *-- kinda nice to have that texture on the screen, keeps it
- *-- from being monotonous.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do open_screen
- *-- Example.....: do open_screen
- *-- Returns.....: None
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private nRow, cBackDrp, nHoldRow
-
- clear
- nRow=0
- cBackdrp = chr(176) && chr(176) = "░", chr(177) = "▒", chr(178) = "▓"
- do while nRow < 3
- @nRow,0 to nRow+3,79 cBackdrp && fill this section of the screen
- nHoldRow = nRow
- nRow = nRow + 6
- @nRow,0 to nRow+3,79 cBackdrp
- nRow = nRow + 6
- @nRow,0 to nRow+3,79 cBackdrp
- nRow = nRow + 6
- @nRow,0 to nRow+3,79 cBackdrp
- nRow = nHoldRow + 1
- enddo
- @24,0 to 24,79 cBackdrp
-
- RETURN
- *-- EoP: OpenScreen
-
- PROCEDURE JazClear
- *-------------------------------------------------------------------------------
- *-- Programmer..: Rick Price (HAMMETT)
- *-- Date........: 05/24/1991
- *-- Notes.......: Used to clear the screen from the middle out --
- *-- could be used with OpenScreen, above. I got this
- *-- from Rick at the same time I got the other routine above ...
- *-- This requires a full screen (0,0 to 23,79 ...)
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do jazclear
- *-- Examples....: do jazclear
- *-- Returns.....: None
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private nWinR1, nWinR2, nWinC1, nWinC2, nStep, mnWinC1, mnWinC2, ;
- mnWinR1, mnWinR2, nStep, nTmpAdjR, nTmpAdjC, nAdjRow, nAdjCol
- private nColLeft, nColRite, nRowTop, nRowBot
-
- nWinR1 = 0 && row 1
- nWinR2 = 24 && row 2
- nWinC1 = 0 && column 1
- nWinC2 = 79 && column 2
- nStep = 1 && amount to increment by
- * set starting point
- mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1
- mnWinC2 = mnWinC1+1
- mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1
- mnWinR2 = mnWinR1+1
-
- ** Adjust step offset values: nColOff & nRowOff
- ** Vertical steps: nWinR1-nWinR1
- nTmpAdjR = int((nWinR2 - nWinR1)/2)
- nTmpAdjC = int((nWinC2 - nWinC1)/2)
-
- nAdjRow = ;
- iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep
-
- nAdjCol = ;
- iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep
-
- ncolleft = nWinC1
- ncolrite = nWinC2
- nRowTop = nWinR1
- nRowBot = nWinR2
- nWinC1 = mnWinC1
- nWinC2 = mnWinC2
- nWinR1 = mnWinR1
- nWinR2 = mnWinR2
- do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ;
- nWinR1 # nRowTop .or. nWinR2 # nRowBot)
-
- * Adjust coordinates for the clear (moving out from the middle)
- nWinR1 = ;
- nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop)
- nWinR2 = ;
- nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2)
- nWinC1 = ;
- nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft)
- nWinC2 = ;
- nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2)
-
- * Perform the clear
- @nWinR1,nWinC1 clear to nWinR2,nWinC2
- @nWinR1,nWinC1 to nWinR2,nWinC2
- enddo
- clear
-
- RETURN
- *-- EoP: JazClear
-
- PROCEDURE Wipe
- *-------------------------------------------------------------------------------
- *-- Programmer..: Alan D. Frazier (CALLAE)
- *-- Date........: 01/10/1992
- *-- Notes.......: Used to wipe a window from left to right. Nice effect.
- *-- Parameters are the coordinates of the window ...
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do Wipe with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
- *-- Example.....: define window test from 5,10 to 20,70
- *-- activate window test
- *-- *-- do stuff in window
- *-- do Wipe with 5,10,20,70
- *-- Returns.....: None
- *-- Parameters..: nULRow = Upper (Left) Row
- *-- nULCol = (Upper) Left Column
- *-- nBRRow = Bottom (Right) Row
- *-- nBRCol = (Bottom) Right Column
- *-------------------------------------------------------------------------------
-
- parameter nULRow,nULCol,nBRRow,nBRCol
-
- private nULRow,nULCol,nBRRow,nBRCol,nCurLeft
-
- nCurLeft = 0 && always start at column 0 within the window
- nBRRow = nBRRow - nULRow - 2
- nBRCol = nBRCol - nULCol - 2
-
- do while nCurLeft+2 < nBRCol
- @ 0,nCurLeft clear to nBRRow,nCurLeft + 2
- nCurLeft = nCurLeft + 2
- enddo
-
- @ 0,nBRCol-2 CLEAR TO nBRRow,nBRCol - 1
-
- RETURN
- *-- EoP: Wipe
-
- PROCEDURE Center
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 05/24/1991
- *-- Notes.......: Centers text on the screen with @says
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: This and all other procedures/functions listed in this
- *-- file attributed to Miriam Liskin came from "Liskin's
- *-- Programming dBASE IV Book". Very good, worth the money.
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
- *-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
- *-- Note that the color field may be blank: ""
- *-- Returns.....: None
- *-- Parameters..: nLine = Line or Row for @/Say
- *-- nWidth = Width of screen
- *-- cColor = Colors to be used ("Forg/Back") (may be nul "", in
- *-- order to use the default colors of window/screen)
- *-- cText = Message to center on screen
- *-------------------------------------------------------------------------------
-
- parameters nLine,nWidth,cColor,cText
- private nCol
-
- nCol = (nWidth - len(cText)) /2
- @nLine,nCol say cText color &cColor.
-
- RETURN
- *-- EoP: Center
-
- FUNCTION Surround
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 05/24/1991
- *-- Notes.......: Displays a message surrounded by a box anywhere on
- *-- the screen
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (CIS: 71333,1030) to a
- *-- function from original procedure
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>")
- *-- Example.....: cDummy = surround(5,12,"RG+/GB",;
- *-- "Processing ... Do not Touch!")
- *-- Returns.....: Nul/""
- *-- Parameters..: nLine = Line to display "surrounded" message at
- *-- nColumn = Column for same (X,Y coordinates for @SAY)
- *-- cColor = Color variable/colors
- *-- cText = Text to be displayed inside box
- *-------------------------------------------------------------------------------
-
- parameters nLine,nColumn,cColor,cText
-
- cText = " " + trim(cText) + " " && add spaces around text
- @nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double;
- color &cColor. && draw box
- @nLine,nColumn say cText color &cColor. && disp. text
-
- RETURN ""
- *-- EoF: Surround()
-
- FUNCTION Message1
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 05/24/1991
- *-- Notes.......: Displays a message, centered at whatever line you give,
- *-- pauses until user presses a key.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 04/19/1991 Modified by Ken Mayer from Miriam's
- *-- procedure to function
- *-- Calls.......: CENTER Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: message1(<nLine>,<nWidth>,"<cColor>","<cText>")
- *-- Example.....: cDummy = Message1(5,12,"RG+/GB","All Done.")
- *-- Returns.....: numeric value of key pressed by user (cUser)
- *-- Parameters..: nLine = Line to display message
- *-- nWidth = Width of screen
- *-- cColor = Colors for display
- *-- cText = Text to be displayed.
- *-------------------------------------------------------------------------------
-
- parameters nLine,nWidth,cColor,cText
- private cCursor, cUser
-
- @nLine,0
- cCursor = set("CURSOR") && store current state of CURSOR
- set cursor off && turn it off
- do center with nLine,nWidth,cColor,cText
- cUser = inkey(0)
- set cursor &cCursor && set cursor to original state
- @nLine,0 && erase line ...
-
- RETURN cUser
- *-- EoF: Message1()
-
- FUNCTION Message2
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 06/08/1992
- *-- Notes.......: Displays a message in a window, pauses for user to
- *-- press key
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
- *-- 04/29/1991 - Modified by Ken Mayer to add shadow
- *-- 06/08/1992 - Modified by same, to do EXPLICIT setting of
- *-- colors for window used.
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- CENTER Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: message2("<cText>","<cColor>")
- *-- Example.....: cDummy = message2("Finished Processing!",;
- *-- "RG+/GB,,RG+/GB")
- *-- Returns.....: numeric value of key pressed by user (cUser)
- *-- Parameters..: cText = Text to be displayed in window
- *-- cColor = Colors for window
- *-------------------------------------------------------------------------------
-
- parameters cText,cColor
- private cCursor, cUser
-
- cCursor = set("CURSOR")
- set cursor off
- save screen to sMessage
-
- *-- NOW we see what happens ...
- activate screen
- define window wMessage from 10,10 to 14,70 double color &cColor
- do shadow with 10,10,14,70
- activate window wMessage
-
- do center with 1,60,"",cText
- wait "" to cUser
-
- *-- cleanup
- set cursor &cCursor
-
- *-- remove window ...
- deactivate window wMessage
- release window wMessage
- restore screen from sMessage
- release screen sMessage
-
- RETURN cUser
- *-- EoF: Message2()
-
- FUNCTION Message3
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 06/08/1992
- *-- Notes.......: Displays a message in a window, pauses for user,
- *-- will wrap a long message inside the window.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
- *-- 04/29/1991 - Modified to Ken Mayer add shadow
- *-- 06/08/1992 - Modified to explicitly set the colors ...
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: Message3("<cText>","<cColor>")
- *-- Example.....: cDummy = Message3("This is a long message that will be"+;
- *-- "wrapped around inside the window.","rg+/gb,,rg+/gb")
- *-- Returns.....: numeric value of key used to exit window (cUser)
- *-- Parameters..: cText = Text to be displayed
- *-- cColor = Colors for window
- *-------------------------------------------------------------------------------
-
- parameters cText,cColor
- private nLines,cCursor,cUser,nLMargin,nRMargin,cAlignment,lWrap
-
- nLines = int(len(cText) / 38) + 5 && set # of lines for window
-
- cCursor = set("CURSOR")
- set cursor off
- save screen to sMessage
-
- *-- define/activate window
- activate screen
- define window wMessage from 8,20 to 8+nLines,60 double color &cColor
- do shadow with 8,20,8+nLines,60
- activate window wMessage
-
- nLmargin = _lmargin
- nRmargin = _rmargin
- cAlignment = _alignment
- lWrap = _wrap
-
- _lmargin = 1
- _rmargin = 38
- _alignment = "CENTER"
- _wrap = .t.
-
- ?cText
- ?
- wait " Press any key to continue . . ." to cUser
-
- _lmargin = nLmargin
- _rmargin = nRmargin
- _alignment = cAlignment
- _wrap = lWrap
-
- set cursor &cCursor
- deactivate window wMessage
- release window wMessage
- restore screen from sMessage
- release screen sMessage
-
- RETURN cUser
- *-- EoF: Message3()
-
- FUNCTION Message4
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 06/08/1992
- *-- Notes.......: Displays a 2-line message in a predefined window
- *-- and pauses
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
- *-- 04/29/1991 - Modified to Ken Mayer add shadow
- *-- 06/08/1992 -- Modified to explicitly deal with colors
- *-- 11/09/1992 - Modified by Joey Carroll to deal with text
- *-- parameters being too long.
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- CENTER Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: message4("<cText1>","<cText2>","<cColor>")
- *-- Example.....: cDummy = message4("Finished processing.","There are ";
- *-- +ltrim(str(reccount()))+" Records in this file.",;
- *-- "rg+/rg,rg+/rg,rg+/rg")
- *-- Returns.....: numeric value of key pressed by user to exit window (cUser)
- *-- Parameters..: cText1 = First line of message
- *-- cText2 = Second line of message
- *-- cColor = Colors for window
- *-------------------------------------------------------------------------------
-
- parameters cText1,cText2,cColor
- private cCursor,cUser,nLMargin,nRMargin,lWrap
-
- *-- if text params are too long, cut 'em off
- cText1 = left(cText1,58)
- cText2 = left(cText2,58)
-
- cCursor = set("CURSOR")
- set cursor off
- save screen to sMessage
-
- activate screen
- define window wMonitor from 10,10 to 17,70 double color &cColor
- do shadow with 10,10,17,70
- activate window wMonitor
-
- nLmargin = _lmargin
- nRmargin = _rmargin
- lWrap = _wrap
- _lmargin = 1
- _rmargin = 58
- _wrap = .t.
-
- do center with 1,58,"",cText1
- do center with 2,58,"",cText2
- do center with 4,58,"","Press any key to continue . . ."
- wait "" to cUser
-
- _lmargin = nLmargin
- _rmargin = nRmargin
- _wrap = lWrap
- set cursor &cCursor
- deactivate window wMonitor
- release window wMonitor
- restore screen from sMessage
- release screen sMessage
-
- RETURN cUser
- *-- EoF: Message4()
-
- FUNCTION ScrnHead
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 05/23/1991
- *-- Notes.......: Displays a heading on the screen in a box 2
- *-- spaces wider than the text, with a custom border (double
- *-- line top, single the rest)
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 4/29/1991 - Modified by Ken Mayer to add shadow
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: scrnhead("<cColor>","<cText>")
- *-- Examples....: cDummy = ScrnHead("rg+/gb","Print Financial Report")
- *-- Returns.....: nul/""
- *-- Parameters..: cColor = Colors to display box/text in
- *-- cText = text to be displayed.
- *-------------------------------------------------------------------------------
-
- parameters cColor,cText
- private cTextStart,cText2
-
- cText2 = " "+trim(cText)+" " && ad spaces to left and right
- cTextstart = (80-len(trim(cText2)))/2
- activate screen
- do shadow with 1,cTextstart-1,3,81-cTextstart
- @1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217;
- color &cColor. && display box
- @2, cTextstart say cText2 color &cColor. && display text
-
- RETURN ""
- *-- EoF: ScrnHead()
-
- FUNCTION YesNo
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 06/08/1992
- *-- Notes.......: Asks a yes/no question in a dialog window/box
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
- *-- 04/29/1991 - Modified by Ken Mayer add shadow
- *-- 05/13/1991 - Modified by Ken Mayer remove need for extra
- *-- procedures (YES/NO) that were used for returning
- *-- values from Menu
- *-- (suggested by Clinton L. Warren (VBCES))
- *-- 01/20/1992 - Modified by Martin Leon (HMan) to handle user
- *-- pressing 'Y' or 'N' keys (with ON KEY ...).
- *-- 04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
- *-- as occaisional problems appear otherwise.
- *-- 06/08/1992 - Modified (Ken Mayer) to deal with explicit
- *-- color processing.
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- CENTER Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>")
- *-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",;
- *-- "This will destroy the data";
- *-- "in this record.";
- *-- "rg+/gb,n/w,rg+/gb")
- *-- delete
- *-- else
- *-- skip
- *-- endif
- *--
- *-- The middle set of colors should be different, as they
- *-- will be the colors of the YES/NO selections ...
- *-- Options may be blank by using nul values ("")
- *-- Returns.....: .t./.f. depending on user's choice from menu
- *-- Parameters..: lAnswer = default value (Yes or No) for menu
- *-- cMess1 = First line of Message
- *-- cMess2 = Second line of message
- *-- cMess3 = Third line of message
- *-- cColor = Colors for window/menu/box
- *-------------------------------------------------------------------------------
-
- parameter lAnswer,cMess1,cMess2,cMess3,cColor
- private nLMargin,nRMargin,lWrap
-
- save screen to sYesno
- activate screen
- define window wYesno from 8,20 to 15,60 double color &cColor
-
- define menu mYesno
- *-- remove && from MESSAGE option if using or might be used on Mono system
- define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
- define pad pNo of mYesno Prompt "[No]" at 5,25 && message "No"
- on selection pad pYes of mYesno deactivate menu
- on selection pad pNo of mYesno deactivate menu
-
- do shadow with 8,20,15,60
- activate window wYesno
- nLmargin = _lmargin && store system values
- nRmargin = _rmargin
- lWrap = _wrap
- _lmargin = 2 && set local values
- _rmargin = 38
- _wrap = .t.
-
- do center with 0,38,"",cMess1 && center the text
- do center with 2,38,"",cMess2
- do center with 3,38,"",cMess3
-
- *-- deal with user pressing 'Y' or 'N' ...
- on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
- on key label N keyboard IIF( PAD() = "PNO", "", CHR(4) )+chr(13)
- *-- otherwise deal with regular "menu" abilities
- clear typeahead
- if lAnswer
- activate menu mYesno pad pYes
- else
- activate menu mYesno pad pNo
- endif
-
- *-- clear out ON KEY settings ...
- on key label Y
- on key label N
- _lmargin = nLmargin && reset system values
- _rmargin = nRmargin
- _wrap = lWrap
- deactivate window wYesno
- release window wYesno
- restore screen from sYesno
- release screen sYesno
- release menu mYesno
-
- RETURN iif(pad()="PYES",.t.,.f.)
- *-- EoF: YesNo()
-
- FUNCTION YesNo2
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 06/08/1992
- *-- Notes.......: Asks a yes/no question in a dialog window/box
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
- *-- 04/29/1991 - Modified by Ken Mayer add shadow
- *-- 05/13/1991 - Modified by Ken Mayer remove need for extra
- *-- procedures (YES/NO) that were used for returning
- *-- values from Menu
- *-- (suggested by Clinton L. Warren (VBCES))
- *-- 11/15/1991 - Copied YesNo, modified to allow "location"
- *-- options -- useful for some screens ...
- *-- 01/20/1992 - Modified by Martin Leon (HMAN) to allow user to
- *-- press 'Y' or 'N' and have them recognized ...
- *-- 04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
- *-- as occaisional problems appear otherwise.
- *-- 06/08/1992 - Modified by same for explicit color sets.
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- CENTER Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: yesno2(<lAnswer>,"<cWhere>",;
- *-- "<cMess1>","<cMess2>","<cMess3>","<cColor>")
- *-- Example.....: if YesNo2(.t.,"UL","Do You Really Wish To Delete?",;
- *-- "This will destroy the data";
- *-- "in this record.";
- *-- "rg+/gb,n/w,rg+/gb")
- *-- delete
- *-- else
- *-- skip
- *-- endif
- *--
- *-- The middle set of colors should be different, as they
- *-- will be the colors of the YES/NO selections ...
- *-- Options may be blank by using nul values ("")
- *-- Returns.....: .t./.f. depending on user's choice from menu
- *-- Parameters..: lAnswer = default value (Yes or No) for menu
- *-- cWhere = location on screen:
- *-- "UL" = Upper Left
- *-- "UC" = Upper Center
- *-- "UR" = Upper Right
- *-- "CL" = Center Left
- *-- "CC" = Center Center
- *-- "CR" = Center Right
- *-- "BL" = Bottom Left
- *-- "BC" = Bottom Center
- *-- "BR" = Bottom Right
- *-- cMess1 = First line of Message
- *-- cMess2 = Second line of message (may be nul = "")
- *-- cMess3 = Third line of message (may be nul = "")
- *-- cColor = Colors for window/menu/box
- *-------------------------------------------------------------------------------
-
- parameter lAnswer,cWhere,cMess1,cMess2,cMess3,cColor
- private cExact,cW1,cW2,nULB,nBRR,nULC,nBRC,nLMargin,nRMargin,lWrap
-
- cExact = set("EXACT")
- save screen to sYesno
-
- *-- see what the user gave us ...
- if len(trim(cWhere)) > 0
- cW1 = upper(left(cWhere,1)) && first coordinate (vertical)
- cW2 = upper(right(cWhere,1)) && second coordinate (horizontal)
- else
- cW1 = "C"
- cW2 = "C"
- endif
- *-- deal with vertical placement
- do case
- case cW1 = "U"
- nULR = 1 && upper left row
- nBRR = 8 && bottom right row
- case cW1 = "C"
- nULR = 8
- nBRR = 15
- case cW1 = "B"
- nULR = 15
- nBRR = 22
- endcase
- *-- deal with horizontal placement
- do case
- case cW2 = "L"
- nULC = 5 && upper left column
- nBRC = 45 && bottom right column
- case cW2 = "R"
- nULC = 35
- nBRC = 75
- case cW2 = "C"
- nULC = 20
- nBRC = 60
- endcase
-
- activate screen
- define window wYesno from nULR,nULC to nBRR,nBRC double color &cColor
-
- define menu mYesno
- *-- remove && from MESSAGE option if using or might be used on Mono system
- define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
- define pad pNo of mYesno Prompt "[No]" at 5,25 && message "No"
- on selection pad pYes of mYesno deactivate menu
- on selection pad pNo of mYesno deactivate menu
- *-- start displaying it ... shadow, window ...
- do shadow with nULR,nULC,nBRR,nBRC
- activate window wYesno
- *-- store or set some system values
- nLmargin = _lmargin
- nRmargin = _rmargin
- lWrap = _wrap
- _lmargin = 2 && set local values
- _rmargin = 38
- _wrap = .t.
- *-- display text
- do center with 0,38,"",cMess1 && center the text
- do center with 2,38,"",cMess2
- do center with 3,38,"",cMess3
- *-- set 'y' or 'n' keys ...
- on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
- on key label N keyboard IIF( PAD() = "PNO", "", CHR(4) )+chr(13)
- clear typeahead
- if lAnswer
- activate menu mYesno pad pYes
- else
- activate menu mYesno pad pNo
- endif
-
- *-- reset system ...
- on key label Y
- on key label N
- _lmargin = nLmargin
- _rmargin = nRmargin
- _wrap = lWrap
- deactivate window wYesno
- release window wYesno
- restore screen from sYesno
- release screen sYesno
- release menu mYesno
- set exact &cExact
-
- RETURN iif(pad()="PYES",.t.,.f.)
- *-- EoF: YesNo2()
-
- FUNCTION ErrorMsg
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 06/08/1992
- *-- Notes.......: Display an error message in a Window:
- *-- ** ERROR [#] **
- *--
- *-- Message 1
- *-- Message 2
- *-- Press any key to continue ...
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 06/08/1992 -- Modified for explicit color handing.
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- CENTER Procedure in PROC.PRG
- *-- ALLTRIM() Function in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>")
- *-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",;
- *-- "rg+/r,rg+/r,rg+/r")
- *-- where "errornum" is an error number or nul,
- *-- message2 and 3 should be 36 characters or less ...
- *-- Colors should include foreground/background,;
- *-- foreground/background,foreground/background
- *-- Returns.....: numeric value of keystroke user presses (cUser)
- *-- Parameters..: cErr = Error # (can be blank, but use "" for blank)
- *-- cMess1 = Error message line 1
- *-- cMess2 = Error message line 2
- *-- cColor = Colors for text/window/border
- *-------------------------------------------------------------------------------
-
- parameters cErr,cMess1,cMess2,cColor
- private cCursor,cUser,cCurColor,cTempCol
-
- save screen to sErr
- activate screen
- define window wErr from 8,20 to 15,60 double color &cColor
- do shadow with 8,20,15,60
- activate window wErr
-
- cCursor = set("CURSOR")
- set cursor off
- if len(trim(cErr)) > 0 && if there's an error number ...
- do center with 0,38,"","** ERROR "+alltrim(cErr)+" **"
- else && otherwise, don't display errornumber
- do center with 0,38,"","** ERROR **"
- endif
- do center with 2,38,"",cMess1
- do center with 3,38,"",cMess2
- do center with 5,38,"","Press any key to continue ..."
- cUser=inkey(0)
-
- set cursor &cCursor
- deactivate window wErr
- release window wErr
- restore screen from sErr
- release screen sErr
-
- RETURN cUser
- *-- EoF: ErrorMsg()
-
- PROCEDURE ProgBar
- *-------------------------------------------------------------------------------
- *-- Programmer..: Joey D. Carroll (JOEY)
- *-- Date........: 06/28/1992
- *-- Notes.......: A visual indicator of program activity, i.e. shows
- *-- user program didn't die during long processes which
- *-- do not normally show 'on screen'. Serves same purpose
- *-- as MONITOR, but is more graphic.
- *-- For best appearance, set cursor 'off' from calling
- *-- program, outside of the loop which calls PROGBAR.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: 10/26/1992 - Fixed bug(feature) so that cMessage prints the
- *-- color requested by cWindCol. Protected existing active
- *-- Window. (Joey Carroll)
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do PROGBAR with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2>, ;
- *-- <cMessage>,<nWindWidth>
- *-- Example.....: *-- determine what process will be monitored and what the
- *-- *-- final value will be, e.g. nReccount = reccount()
- *-- use <anyfile>
- *-- nReccount = reccount()
- *-- set cursor off
- *-- scan
- *-- do progbar with nReccount,",,w+/n","w+/r","w+/g", ;
- *-- "Processing records. Be patient.",40
- *-- *-- do some needed process here
- *-- endscan
- *-- *-- cleanup
- *-- Returns.....: None
- *-- Parameters..: nQuan = maximum number of iterations
- *-- cWindCol = the window colors
- *-- cFillCol1 = color of ruler before process
- *-- cFillCol2 = color of ruler after process
- *-- cMessage = message displayed to user, may be "".
- *-- nWindWid = (optional) desired width of ruler window. If
- *-- not specified, width of screen. If
- *-- specified, will not be less than length of
- *-- message.
- *-------------------------------------------------------------------------------
-
- parameters nQuan,cWindCol,cFillCol1,cFillCol2,cMessage,nWindWidth
- private lMessage,x, nParms
- lMessage = iif(.not. isblank(cMessage), .t., .f.) && was message passed?
- *-- find out # of parameters passed ...
- if val(right(version(),3)) > 1.1
- nParms = pcount()
- else
- nParms = 6
- endif
- nWindWidth = iif(nParms = 6,nWindWidth,78) && all the way if width not passed
- nWindWidth = min(nWindWidth,78) && width param > 78 not allowed
- *-- window width can't be narrower than messsage, so....
- nWindWidth = iif(lMessage,max(nWindWidth,len(cMessage) + 2),nWindWidth)
- *-- skip this section if we've been here before
- *-- this procedure called from inside a loop
- *-- following section ignored except on first iteration thru loop
- if type("nTimes") = "U" && check to see if we been here before
- save screen to sProgBar
- public nFactor,nTimes,wPrevWind && make these available on all iterations
- *-- was a window active?
- wPrevWind = window()
- nProgLine = iif(set("status") = "ON",20,22) && don't overwrite status
- *-- determine how wide the window needs to be
- define window wProgBar from ;
- nProgLine - iif(lMessage, 2, 1),(80 - (nWindWidth + 2)) / 2 ;
- to nProgLine + 1,(80 + (nWindWidth + 2)) / 2 - 1 ;
- double color &cWindCol
- activate window wProgBar
- @ 0,0 say replicate(".",nWindWidth - 1) && the ruler
- @ 0,0 say "0%" && and some gradation %'s
- @ 0,nWindWidth / 4 - 2 say "25%"
- @ 0,nWindWidth / 2 - 2 say "50%"
- @ 0,3*(nWindWidth / 4) - 2 say "75%"
- @ 0,nWindWidth - 4 say "100%"
- @ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1 && color of ruler before process
- if lMessage
- @ 1,(nWindWidth - (len(cMessage))) / 2 say cMessage
- endif
- nFactor = nQuan/nWindWidth && e.g. how many records per bar part(cols)
- nTimes = 0 && times thru loop
- endif && type("nTimes") = "U"
-
- *-- this section will be processed as many times as required by nQuan
- nTimes = nTimes + 1
- @ 0,0 fill to 0,int(nTimes / nFactor) ;
- - iif(int(nTimes / nFactor) - 1 >= 0, 1, 0) ;
- color &cFillCol2 && color of ruler as processing takes place
- if nTimes = nQuan && we done
- x = inkey(.5) && leave on screen just a liitle while after completion
- *-- cleanup your mess
- deactivate window wProgBar
- release window wProgBar
- restore screen from sProgBar
- release screen sProgBar
- *-- Reactivate window if it existed
- if .not. isblank(wPrevWind)
- activate window &wPrevWind
- endif
- release nProgBar,nFactor,nTimes,lMessage,x,wPrevWind
- endif && nTimes = nQuan
- RETURN
- *-- EoP: ProgBar
-
- FUNCTION Alert2
- *-------------------------------------------------------------------------------
- *-- Programmer..: Adam L. Menkes (SUPREME1)
- *-- Date........: 11/16/1992
- *-- Notes.......: This function based on Alert2()
- *-- This routine creates a popup on the screen with a title and
- *-- one line message, forcing the user to notice the message.
- *-- The user must use the mouse on the 'OK' pad, press <Esc> or
- *-- press <Enter> to move on in the program that called this
- *-- function.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: Alert2()
- *-- Modified to accept the <Enter> key by Ken Mayer.
- *-- 06/19/1992 -- Copied from Adam's original, uses a window,
- *-- shadow, and programmer defineable colors.
- *-- 07/29/1992 -- Joey stepped in and made some modifications
- *-- that seem to have helped as well, including dealing with
- *-- the keyboard buffer.
- *-- 10/09/1992 -- minor change -- title is now same color as
- *-- the "pad".
- *-- Alert22()
- *-- 11/12/1992 -- changed to look more like a Win 3.0/3.1
- *-- window by printing a special 'line' below the title.
- *-- Also removed hard coding which forced border to DOUBLE
- *-- so that if called with border set to NONE, gives even more
- *-- Win-like appearance. Calls a new function written for this
- *-- technique, but can be used in other programs.
- *-- 11/16/1992 -- modified to add cBORDER parameter ... (K. Mayer)
- *-- Calls.......: SHADOW Procedure in PROC.PRG
- *-- CENTER Procedure in PROC.PRG
- *-- JUSTIFY() Function in PROC.PRG
- *-- COLORBRK() Function in PROC.PRG
- *-- FBCLRBRK() Function in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>"[,"<cBorder>"])
- *-- Example.....: ** if no border, I suggest colors which will contrast
- *-- with the active screen or window
- *-- lX = Alert2("Print Aborted","You pressed <ESC>",;
- *-- "rg+/r,w+/b,rg+/r","NONE")
- *-- Returns.....: Logical
- *-- Parameters..: cTitle = Title line
- *-- cMessage = One line message (up to 75 characters)
- *-- cColor = Colors: <window forg/back>,<pad> (and title),<box>
- *-- cBorder = Border type (DOUBLE, SINGLE, NONE, PANEL) --
- *-- optional -- will default to your setting
- *-------------------------------------------------------------------------------
-
- parameters cTitle, cMessage, cColor, cBorder
- private wWindow,nRow,nCol,mPad,cTempCol,cColorF,cColorB,cColorAll,lNoBorder
-
- wWindow = WINDOW() && save current Window
- save screen to sTemp && save the screen
- activate screen
- cDummykey = inkey() && clear out keyboard buffer
- cOldBorder = set("BORDER") && get old border setting
- if .not. type("CBORDER") = "L" && if user set border ...
- set border to &cBorder && start NEW border setting
- endif
- lNoBorder = set("BORDER") = "NONE" && is there a border?
-
- *-- get window coordinates
- *-- this centers from top to bottom, depending on monitor setup ...
- nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8)
- *-- add rows, number depends on border, so the Window is large enough ...
- if lNoBorder
- nBRRow = nULRow + 4
- else
- nBRRow = nULRow + 6
- endif
- *-- left column ...
- nULCol = 36 - (max(len(cTitle),len(cMessage))/2) && center left-right
- *-- right column ...
- nBRCol = nULCol + max(len(cTitle),len(cMessage))+4 && right side?
- *-- Window width ...
- nWidth = nBRCol - nULCol - 1
-
- *-- define window
- activate screen
-
- Define window wAlert from nULRow,nULCol to nBRRow,nBRCol ;
- color &cColor.
-
- *-- display shadow
- do shadow with nULRow,nULCol,nBRRow,nBRCol
-
- *-- start 'er up ...
- activate window wAlert
-
- *-- display title
- cTempCol = colorbrk(cColor,2)
- if len(cTitle) < nWidth
- cTitle = justify(cTitle,iif(lNoBorder,nWidth+2,nWidth),"C")
- if len(cTitle) < nWidth
- cTitle = cTitle + " "
- endif
- endif
-
- *-- display a new type type line to look more like Win
- cColorF = FBClrBrk("B",cTempCol)
- cColorB = FBClrBrk("B",colorbrk(cColor,1))
- cColorAll = cColorF + "/" + cColorB
- if lNoBorder
- do center with 0,nWidth + 3,"&cTempCol",cTitle
- *-- chr(223) looks like this --> ▀ <--
- @ 1,0 say replicate(chr(223),nWidth + 2) color &cColorAll
- else
- do center with 0,nWidth,"&cTempCol",cTitle
- @ 1,0 say replicate(chr(223),nWidth) color &cColorAll
- endif
-
- *-- display message
- do center with 2,nWidth,"",cMessage
-
- *-- define/display a very small menu (one pad)
- define menu mAlert
- define pad pPad1 of mAlert prompt "[OK]" at 4,(nWidth/2-2)
- on selection pad pPad1 of mAlert deactivate menu
-
- *-- added by Ken to deal with <Enter>
- on key label ctrl-M keyboard "{27}"
-
- *-- start it up
- activate menu mAlert
-
- *-- deal with user 'input'
- mPad = pad()
- deactivate window wAlert
- release window wAlert
-
- *-- restore environment, free up RAM by releasing things
- on key label ctrl-m
- restore screen from sTemp
- release screen sTemp
- release menu mAlert
- if "" # wWindow
- activate window &wWindow
- endif
- set border to &cOldBorder
-
- RETURN .not. "" = mPad && not empty pad?
- *-- EoF: Alert2()
-
- PROCEDURE Shadow
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ashton-Tate
- *-- Date........: 01/27/1992
- *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
- *-- picklist functions)
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 05/23/1991 - original procedure.
- *-- 12/14/1991 - Modified by Jim Magnant (TXAGGIE) - to check
- *-- for columns exceeding 79, and temporarily change last col.
- *-- value (so routine doesn't "blow up").
- *-- 01/27/1992 -- Modifiedy by Ken Mayer to check for bottom
- *-- of screen, based on what Jim did above. No further than 23.
- *-- Calls.......: None
- *-- Called by...: Too many to list ...
- *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
- *-- Example.....: save screen to sMain
- *-- activate screen
- *-- define window wError from 5,15 to 15,65 double color;
- *-- rg+/r,rg+/r,rg+/r
- *-- do shadow with 5,15,15,65
- *-- activate window WError
- *-- && perform actions in window
- *-- deactivate window WError
- *-- release window WError
- *-- restore screen from sMain
- *-- release screen sMain
- *-- Returns.....: None
- *-- Parameters..: nULRow = Upper Left Row position
- *-- nULCol = Upper Left Column position (x,y)
- *-- nBRRow = Bottom Right Row position
- *-- nBRCol = Bottom Right Column position (x2,y2)
- *-------------------------------------------------------------------------------
-
- parameters nULRow,nULCol,nBRRow,nBRCOL
- private nTempRow,nTempCol,nIncRow,nIncCol
-
- nTempRow = iif(nBRRow+1>23,23,nBRRow+1)
- nTempCol = iif(nBRCol+2>79,79,nBRCol+2)
- nIncRow = 1
- nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow)
- do while nTempRow <> nULRow .or. nTempCol <> nULCol+2
- nRightCol = nBRCol
- nBRCol = iif(nBRCol + 2 > 79,77,nBRCol)
- nBotRow = nBRRow
- nBRRow = iif(nBRRow + 1 > 23,22,nBRRow)
- @ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n
- nBRCol = nRightCol
- nBRRow = nBotRow
- nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow)
- nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol)
- nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol)
- enddo
-
- RETURN
- *-- EoP: Shadow
-
- FUNCTION VPick
- *-------------------------------------------------------------------------------
- *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
- *-- Date........: 06/08/1992
- *-- Notes.......: Keith wanted a multiple choice picklist routine for use
- *-- with a mouse (or other) ... he got the idea for the AT-USER
- *-- system which he was Beta Testing. Here 'tis ...
- *-- This creates a quick pick-list for multiple-choice, single-
- *-- character input. The first letter of the selected bar is
- *-- returned. If <Esc> is pressed, a null string is returned.
- *-- NOTE: If using this with dBASE IV, 1.1, you must supply
- *-- a parameter for each option below.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: 06/02/1992 -- Keith first gave this to Ken Mayer to use with
- *-- the BORUSER system.
- *-- 06/08/1992 -- Modified to allow passing of a color memvar,
- *-- and then to use explicit color definitions based on it.
- *-- 11/09/1992 - Joey Carrol modified to allow use of function
- *-- when another window is active, and to insure color integrity
- *-- Calls.......: COLORBRK() Function in PROC.PRG
- *-- RECOLOR Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: ?VPick(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>",;
- *-- <lShadow>,<cColor>)
- *-- Example.....: cHow = VPick(12,15,"~BorBBS ID~Lastname",;
- *-- "How do you want the data sorted?","Choose one",;
- *-- "rg+/gb,w+/b,rg+/gb")
- *-- Returns.....: First letter of bar selected, or null if <Esc>.
- *-- Parameters..: nRow = is a numeric value for the top row of the popup.
- *-- nCol = is a numeric value for the left column.
- *-- cOptions = is a string of options with each preceded by
- *-- '~', e.g. "~Screen~Printer~Text File~Return to Menu"
- *-- cTitle = is an optional title, used for the popup heading
- *-- cMessage = is an optional message string for when the popup
- *-- is activated on the screen.
- *-- lShadow = is a logical value indicating whether or not a
- *-- shadow is to be placed under the popup.
- *-- cColor = Colors to be used. Should have three parts --
- *-- <normal/unselected text>,<highlighted text>,
- *-- <border>, using the format "Foreground/Background"
- *-- for each. So examine the example above.
- *-------------------------------------------------------------------------------
-
- parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow,cColor
- private nRow,nCol,cOptions,cTitle,cMessage,lShadow,cTempCol,cCurColor
-
- *-- get number of parameters, and a few setup steps ...
- if val(right(version(),3)) > 1.1 && if version of dBASE (RunTime) > 1.1
- nParameters = pcount()
- else
- nParameters = 7
- endif
- nCount = 0
- cReturn = ""
- cOptions = trim(cOptions)
- cDispMesg = ""
- *-- if number of parameters greater/equal to 5, we may have a message
- *-- at the bottom of the screen ...
- if nParameters >= 5
- if len(cMessage) > 0
- cDispMesg = "MESSAGE "+"'"+cMessage+"'"
- endif
- endif
-
- *-- make it work even if a window is active.
- wPrevWind = window()
- activate screen
-
- *-- define the popup
- define popup pPickList from nRow,nCol &cDispMesg.
- nMessage1 = 0
- *-- if we have 4 or more parameters, one of them is the title ...
- *-- this requires that the first two bars of the menu be skipped ...
- if nParameters >= 4
- if len(cTitle) > 0
- cTitle = " "+cTitle+" "
- nMessage1 = len(cTitle)
- nCount = 2
- endif
- endif
-
- *-- save current colors
- cCurColor = set("ATTRIBUTES")
- *-- set new ones
- cTempCol = colorbrk(cColor,1)
- set color of normal to &cTempCol
- set color of message to &cTempCol
- cTempCol = colorbrk(cColor,2)
- set color of highlight to &cTempCol
- cTempCol = colorbrk(cColor,3)
- set color of box to &cTempCol
-
- *-- now we start parsing the options for the menu. These must have
- *-- a tilde between each, so we look for the first one, and then
- *-- look again to see if there's another after that.
-
- nPos1 = at("~",cOptions) && Look for first tilde
- do while (len(cOptions) > 0) .and. (nPos1 > 0) && parsing loop ...
- if nPos1 > 0
- cSub = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
- nPos2 = at("~",cSub)
- if nPos2 = 0
- nPos2 = len(cSub)
- else
- nPos2 = nPos2 - 1
- endif
- cOptString = " "+left(cSub,nPos2)+" "
- if len(cOptString) > nMessage1
- nMessage1 = len(cOptString)
- endif
- *-- define the actual 'bar' of the menu/picklist ...
- nCount = nCount + 1
- define bar nCount of pPickList prompt cOptString
- cOptions = cSub
- endif
- nPos1 = at("~",cOptions)
- enddo && end of parsing loop
-
- *-- now we deal with defining the actual picklist ...
- if nCount > 0 && if we have something to put in the list ...
- if nParameters >= 4 && if we have a title for the top ...
- if len(cTitle) > 0
- if len(cTitle) < nMessage1
- cTitle = trim(ltrim(cTitle))
- cTitle = space((nMessage1-len(cTitle)) / 2) + cTitle
- endif
- define bar 1 of pPickList prompt cTitle skip
- define bar 2 of pPickList prompt replicate(chr(196),nMessage1) skip
- endif
- endif
- *-- define what to do when a choice is made ...
- on selection popup pPickList deactivate popup
- *-- if we have a shadow, let's save screen and do the shadow
- *-- before popping up the picklist
- if nParameters => 6
- if lShadow
- save screen to sPickScr
- @ nRow+1,nCol+2 fill to nRow+nCount+2,nCol+nMessage1+3 color w/n
- endif
- else
- lShadow = .f.
- endif
- *-- there we are ...
- activate popup pPickList
-
- *-- cleanup
- if lShadow
- restore screen from sPickScr
- release screen sPickScr
- endif
-
- *-- deal with what to 'return' ...
- if lastkey() = 27
- cReturn = ""
- else
- cReturn = substr(prompt(),2,1)
- endif
-
- endif && nCount > 0
-
- *-- we're done with it ... return it back to the electronic byte storage
- *-- bins ...
- release popup pPickList
- do ReColor with cCurColor
-
- *-- was there an existing window?
- if .not. isblank(wPrevWind)
- activate window &wPrevWind
- endif
-
- RETURN cReturn
- *-- EoF: VPick()
-
- FUNCTION HPick
- *-------------------------------------------------------------------------------
- *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
- *-- Date........: 06/12/1992
- *-- Notes.......: Creates a horizontal pick list for multiple-choice single-
- *-- character input. The first letter of the selected pad is
- *-- returned. If <ESC> is pressed, a null string is returned.
- *-- Written for.: dBASE IV, 1.1, 1.5
- *-- Rev. History: 11/09/1992 - Modified to allow use when another window is
- *-- active, and to ensure color integrity (Joey Carroll).
- *-- Calls.......: COLORBRK() Function in PROC.PRG
- *-- RECOLOR Procedure in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: HPICK(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>";
- *-- <lShadow>,"<cColor>")
- *-- Example.....: x=HPick(8,5,"~Screen~Printer~Text File~Return to Menu",;
- *-- "Output Options","Select one, or <Esc> to exit",;
- *-- .t.,"rg+/gb,w+/b,rg+/gb")
- *-- Returns.....: First letter of selected 'pad', or null if <Esc>.
- *-- Parameters..: nRow = a numeric value for the top row of the popup.
- *-- nCol = a numeric value for the left column of the popup.
- *-- cOptions = a string of options with each preceded by '~',
- *-- e.g. "~Screen~Printer~Text File~Return to Menu"
- *-- cTitle = an optional title, used for the popup heading
- *-- cMessage = an optional message string for when the popup
- *-- is activated on the screen.
- *-- lShadow = a logical value indicating whether or not a
- *-- shadow is to be placed under the popup.
- *-- cColor = Colors passed to function in format:
- *-- <Text/Unselected Pad>,<Selected Pad>,<Border>
- *-------------------------------------------------------------------------------
-
- parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow, cColor
- private cPickColor,cTempCol
- *-- get number of parameters, and a few setup steps
- *-- if version 1.5 or later, # of parms is optional ...
- if val(right(version(),3)) > 1.1 && if version of dBASE > 1.1
- nParameters = pcount()
- else
- nParameters = 7
- endif
- nCount = 0
- nStartCol = nCol
- cOptions = trim(cOptions)
- cDispMess = ""
-
- *-- make it work even if a window is active
- wPrevWind = window()
- activate screen
-
- *-- save current colors, set up colors for this routine
- cPickColor = set("ATTRIBUTES")
- cTempCol = colorbrk(cColor,1)
- set color of normal to &cTempCol
- set color of message to &cTempCol
- cTempCol = colorbrk(cColor,2)
- set color of highlight to &cTempCol
- cTempCol = colorbrk(cColor,3)
- set color of box to &cTempCol
-
- cPadName = "p"
- *-- if # of parameters => 5, we may have a message at the bottom of the
- *-- screen ...
- if nParameters >= 5
- if len(cMessage) > 0
- cDispMess = "MESSAGE "+"'"+cMessage+"'"
- endif
- endif
- *-- start defining the menu ...
- define menu mHPick &cDispMess.
- if nParameters >= 4
- if len(cTitle) > 0
- cTitle = " "+cTitle+" "
- endif
- endif
-
- *-- here, we have to parse the cOptions field for the tilde "~" character,
- *-- which is how we know we have a new pad ...
- nPos1 = at("~",cOptions) && position of first tilde
- do while (len(cOptions) > 0) .and. (nPos1 > 0) && parsing loop
- if nPos1 = 0 .and. (len(cOptions) > 0)
- nPos1 = len(cOptions)
- endif
- if nPos1 > 0
- cSubString = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
- nPos2 = at("~",cSubString)
- if nPos2 = 0
- nPos2 = len(cSubString)
- else
- nPos2 = nPos2 - 1
- endif
- cOptString = " "+left(cSubString,nPos2)+" "
- nCount = nCount + 1
- cPadName = "p"+ltrim(trim(str(nCount)))
- define pad &cPadName of mHPick prompt cOptString at nRow,nCol
- nCol = nCol + len(cOptString)
- on selection pad &cPadName of mHPick deactivate menu
- cOptions = cSubString
- endif
- nPos1 = at("~",cOptions)
- enddo
-
- *-- done figure that out. On to more stuff ...
- save screen to sPickList
- *-- do we have a shadow?
- if lShadow
- @ nRow,nStartCol+2 fill to nRow+2,nCol+2
- endif
- *-- draw border
- @ nRow-1,nStartCol-1 to nRow+1,nCol
- *-- display 'title'
- if len(cTitle) > 0
- @ nRow-1,nStartCol+1 say cTitle
- endif
- *-- start 'er up ...
- activate menu mHPick
-
- *-- that's it ... return screen to it's original
- *-- state ...
- restore screen from sPickList
- release screen sPickList
-
- *-- deal with user keystroke/selection ...
- if lastkey() = 27
- cReturn = ""
- else
- cReturn = substr(prompt(),2,1)
- endif
-
- *-- cleanup.
- release menu mHPick
- do ReColor with cPickColor && reset colors
-
- *-- was there an existing window?
- if .not. isblank(wPrevWind)
- activate window &wPrevWind
- endif
-
- RETURN cReturn
- *-- EoF: HPick()
-
- *===============================================================================
- * COLOR PROCESSING -- These routines handle setting colors, dealing with
- * checking how colors are set, and so on. Anything that's not here is in
- * the library file: COLOR.PRG.
- *===============================================================================
-
- PROCEDURE SetColor
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 07/24/1992
- *-- Notes.......: This routine is designed set colors of the primary "areas"
- *-- on the screen, based on a color memvar being passed to it.
- *-- This color memvar should contain two sets of colors (normal
- *-- and enhanced). See below for more details.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: ColorBrk() Function in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: do SetColor with <cColorVar>
- *-- Example.....: cOldColor = set("ATTRIBUTES") && save old colors
- *-- do SetColor with cl_dialog
- *-- *-- do whatever needs to be done with these colors
- *-- do ReColor with cOldColor && restore old colors
- *-- Returns.....: None
- *-- Parameters..: cColorVar = Color memvar. This must contain a "normal"
- *-- color and a "highlight" color in the format:
- *-- <forg>/<back>,<forg>/<back>
- *-- i.e., "rg+/gb,w+/b"
- *-------------------------------------------------------------------------------
-
- parameters cColorVar
- private cNormCol,cHighCol
-
- cNormCol = colorbrk(cColorVar,1) && extract "normal" colors
- cHighCol = colorbrk(cColorVar,2) && extract "highlight" colors
-
- set color of normal to &cNormCol && regular screen/text colors
- set color of messages to &cNormCol && messages/menu pads, etc.
- set color of box to &cHighCol && borders
- set color of fields to &cHighCol && data entry fields
- set color of highlight to &cHighCol && highlighted items in menus, etc.
-
- RETURN
- *-- EoP: SetColor
-
- PROCEDURE ReColor
- *-------------------------------------------------------------------------------
- *-- Programmer..: Jay Parsons (CIS: 70160,340)
- *-- Date........: 04/23/1992
- *-- Notes.......: Restores colors to those held in a string of the form
- *-- returned by set("ATTRIBUTE").
- *-- Written for.: dBASE IV, Versions 1.0 - 1.5.
- *-- Rev. History: None
- *-- Calls : None
- *-- Called by...: Any
- *-- Usage.......: DO ReColor WITH <cColors>
- *-- Example.....: DO Recolor WITH OldColors
- *-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE").
- *-- Side effects: Changes the screen colors.
- *-------------------------------------------------------------------------------
-
- parameters cColors
- private cThis, cNext, nAt, cLeft, nX, cAreas
- cAreas = " NORMHIGHBORDMESSTITLBOX INFOFIEL"
- cLeft = cColors + ", "
- nX = 0
- do while nX < 8
- nX = nX + 1
- cThis = substr( cAreas, 4 * nX, 4 )
- if nX = 3
- nAt = at( "&", cLeft )
- cNext = left( cLeft, nAt - 2 )
- cLeft = substr( cLeft, nAt + 3 )
- SET COLOR TO , , &cNext
- else
- nAt = at( ",", cLeft )
- cNext = left( cLeft, nAt - 1 )
- cLeft = substr( cLeft, nAt + 1 )
- SET COLOR OF &cThis TO &cNext
- endif
- enddo
-
- RETURN
- *-- EoP: ReColor
-
- FUNCTION ColorBrk
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 07/22/1992
- *-- Notes.......: This routine is designed to be used with any of my functions
- *-- and procedures that accept a memory variable for color,
- *-- and use a window. It's purpose is to break that color var
- *-- into it's components (depending on which one the user wants)
- *-- and return those components, so that they can then be used
- *-- in SET COLOR OF ... commands.
- *-- Written for.: dBASE IV, 1.1, 1.5 (written because of 1.5, but will work in
- *-- 1.1)
- *-- Rev. History: 07/22/1992 - modified to handle memvars/color strings that
- *-- may have only two parts to them (no <border>...), so that if
- *-- the <nField> parm is 2, we get a valid value.
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: ColorBrk(<cColorVar>,<nField>)
- *-- Example.....: set color of normal to ColorBrk(cColor,1)
- *-- Returns.....: Either the field you asked for (1 thru 3) or null string ("").
- *-- Parameters..: cColorVar = Color variable to extract data from
- *-- Assumes the form: <main color>,<highlight>,<border>
- *-- Where each part uses: <foreground>/<background> format
- *-- i.e., rg+/gb,w+/b,rg+/gb
- *-- nField = Field you want to extract
- *-------------------------------------------------------------------------------
-
- parameters cColorVar, nField
- private cReturn, cExtracted
-
- do case
- case nField = 1
- cReturn = left(cColorVar,at(",",cColorVar)-1)
- case nField = 2
- cExtract = substr(cColorVar,at(",",cColorVar)+1) && everything to
- && right of comma
- if at(",",cExtract) > 0
- cReturn = left(cExtract,at(",",cExtract)-1) && left of second ,
- else
- cReturn = cExtract
- endif
- case nField = 3
- cExtract = substr(cColorVar,at(",",cColorVar)+1)
- cReturn = substr(cExtract,at(",",cExtract)+1)
- otherwise
- cReturn = ""
- endcase
-
- RETURN cReturn
- *-- EoF: ColorBrk()
-
- FUNCTION FBClrBrk
- *------------------------------------------------------------------------------
- *-- Programmer..: Joey D. Carroll (JOEY on USSBBS)
- *-- Date........: 11/12/1992
- *-- Notes.......: Extracts foreground/background colors from a string in the
- *-- form of a literal "n/gb" or of a variable. It is useful
- *-- to use COLORBRK() to obtain this value.
- *-- Written for.: dBASE IV, ver 1.5
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: ?? FBClrBrk("B","w+/gr")
- *-- Example.....: cNormalClr = "w+/gr"
- *-- cForeClr = FBClrBrk("F",cNormalClr) && = "w+"
- *-- cBackClr = FBClrBrk("B",cNormalClr) && = "gr"
- *-- Returns.....: a sub-string of cColor
- *-- Parameters..: cType = "F" for foreground color "B" for Background
- *-- cColor = the color you want to extract from
- *------------------------------------------------------------------------------
- parameters cType,cColor
- private cRetClr
- if upper(cType) = "F"
- cRetClr = iif(at("/",cColor) = 0,cColor,left(cColor,at("/",cColor)-1))
- else && = "B"
- cRetClr = substr(cColor,at("/",cColor) + 1,2)
- endif
-
- RETURN cRetClr
- *-- EoF: FBClrBrk()
-
- *===============================================================================
- * STRING Manipulation. Most of these are in the library file: STRINGS.PRG
- * The ones here are common to a lot of apps and functions, and are here so
- * that the library STRINGS.PRG need not be called.
- *===============================================================================
-
- FUNCTION AllTrim
- *-------------------------------------------------------------------------------
- *-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain)
- *-- Date........: 5/23/1991
- *-- Notes.......: Complete trims edges of field (left and right)
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: alltrim(<cString>)
- *-- Example.....: ? alltrim(" Test String ")
- *-- Returns.....: Trimmed string, i.e.:"Test String"
- *-- Parameters..: cString = string to be trimmed
- *-------------------------------------------------------------------------------
-
- parameters cString
-
- RETURN ltrim(rtrim(cString))
- *-- EoF: AllTrim()
-
- FUNCTION Justify
- *-------------------------------------------------------------------------------
- *-- Programmer..: Roland Bouchereau (Ashton-Tate)
- *-- Date........: 12/23/1992
- *-- Notes.......: Used to pad a field/string on the right, left or both,
- *-- justifying or centering it within the length specified.
- *-- If the length of the string passed is greater than
- *-- the size needed, the function will truncate it.
- *-- Taken from Technotes, June 1990. Defaults to Left Justify
- *-- if invalid TYPE is passed ...
- *-- Written for.: dBASE IV, 1.0
- *-- Rev. History: Original function 06/15/1991
- *-- 12/17/1991 -- Modified into ONE function from three by
- *-- Ken Mayer, added a third parameter to handle that.
- *-- 12/23/1992 -- Modified by Joey Carroll to use STUFF()
- *-- instead of TRANSFORM().
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: Justify(<cFld>,<nLength>,"<cType>")
- *-- Example.....: ?? Justify(Address,25,"R")
- *-- Returns.....: Padded/truncated field
- *-- Parameters..: cFld = Field/Memvar/Character String to justify
- *-- nLength = Width to justify within
- *-- cType = Type of justification: L=Left, C=Center,R=Right
- *-------------------------------------------------------------------------------
-
- parameters cFld,nLength,cType
- private cReturn
-
- cType = upper(cType) && just making sure ...
- if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC"
- *-- set a picture function of 'X's, with @I,@J or @B function
- cReturn = space(nLength)
- cReturn = stuff(cReturn,;
- iif(cType = "C",(nLength-len(cFld))/2,;
- iif(cType = "R",nLength-len(cFld)+1,1)),;
- len(cFld),cFld)
- else
- cReturn = ""
- endif
-
- RETURN cReturn
- *-- EoF: Justify()
-
- FUNCTION State
- *-------------------------------------------------------------------------------
- *-- Programmer..: David G. Franknbach (FRNKNBCH)
- *-- Date........: 04/22/1992
- *-- Notes.......: Validation of state codes -- used to ensure that a user
- *-- doing data entry will enter the proper codes. Added a few
- *-- US Territory codes as well (Puerto Rico, etc.)
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 12/02/1991
- *-- 03/11/1992 -- Modified by Ken Mayer to handle
- *-- the extra US Territories, and to ensure that the data is
- *-- at least temporarily in upper case when doing the check ...
- *-- 04/22/1992 -- Modified by Jay Parsons to shorten
- *-- (simplify) the routine by removing the cSTATE2 memvar.
- *-- Calls.......: None
- *-- Called by...: None
- *-- Usage.......: STATE(<cState>)
- *-- Example.....: @5,10 get cState valid required state(cState);
- *-- error chr(7)+"This is not a valid state code!"
- *-- Returns.....: Logical (.t. if found, .f. otherwise)
- *-- Parameters..: cState = state code to be checked ....
- *-------------------------------------------------------------------------------
-
- parameters cState
-
- cStateList = "AL|AK|AZ|AR|CA|CO|CT|DE|DC|FL|GA|HI|ID|IL|IN|IA|KS|KY|LA|"+;
- "ME|MD|MA|MI|MN|MS|MO|MT|NE|NV|NH|NJ|NM|NY|NC|ND|OH|OK|OR|"+;
- "PA|RI|SC|SD|TN|TX|UT|VT|VA|WA|WV|WI|WY|PR|AS|GU|CM|TT|VI|"
- lOK = upper(cState) $ cStateList
-
- RETURN lOK
- *-- EoF: State()
-
- *===============================================================================
- * DATE HANDLING ROUTINES -- Most of these are now in the library file:
- * DATES.PRG (included with this version of PROC). However, a few are below,
- * as they have become 'standard' routines in many of my systems.
- *===============================================================================
-
- FUNCTION DateText
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 05/23/1991
- *-- Notes.......: Display date in format Month, day year (e.g., July 1,1991)
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: DateText(<dDate>)
- *-- Example.....: ? datetext(date())
- *-- Returns.....: July 1, 1991
- *-- Parameters..: dDate = date to be converted
- *-------------------------------------------------------------------------------
-
- parameters dDate
-
- RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
- *-- EoF: DateText()
-
- FUNCTION DateText2
- *-------------------------------------------------------------------------------
- *-- Programmer..: Miriam Liskin
- *-- Date........: 05/23/1991
- *-- Notes.......: Display date in format day-of-week, Month day, year
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: DateText2(<dDate>)
- *-- Example.....: ? DateText2(date())
- *-- Returns.....: Thursday, July 1, 1991
- *-- Parameters..: dDate = date to be converted
- *-------------------------------------------------------------------------------
-
- parameters dDate
-
- RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+;
- ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
- *-- EoF: DateText2()
-
- FUNCTION Age
- *-------------------------------------------------------------------------------
- *-- Programmer..: Martin Leon (HMAN)
- *-- Date........: 10/23/91
- *-- Notes.......: Returns age of person, given their birthdate as of DATE(),
- *-- effectively, as of "Today".
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: Age(<dBDay>)
- *-- Example.....: ? "Joe is "+ltrim(str(age(dBDay)))+" today ..."
- *-- Returns.....: Numeric value in years
- *-- Parameters..: dBDay = birthdate of person attempting to find age of.
- *-------------------------------------------------------------------------------
-
- parameters dBDay
- private dToday,nYears
-
- dToday = date()
- nYears = year(dToday) - year(dBDay)
- do case
- case month(dBDay) > month(dToday)
- nYears = nYears - 1
- case month(dBDay) = month(dToday)
- if day(dBDay) > day(dToday)
- nYears = nYears - 1
- endif
- endcase
-
- RETURN nYears
- *-- EoF: Age()
-
- *===============================================================================
- * FIELD HANDLING ROUTINES -- Unique searches, string manipulation ...
- * The ones left in PROC.PRG are the more commonly used ones. Anything else is
- * in the library file: FIELDS.PRG.
- *===============================================================================
-
- FUNCTION IsUnique
- *-------------------------------------------------------------------------------
- *-- Programmer..: Clinton L. Warren (VBCES)
- *-- Date........: 04/28/1992
- *-- Notes.......: Checks to see if an index key already exists in the current
- *-- selected database. This function was inspired by Tom
- *-- Woodward's Chk4Dup UDF.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: May 15, 1991 Version 1.1 Added check for zero record database
- *-- May 7, 1991 Version 1.0 Initial 'release'.
- *-- 04/28/1992 -- modified for dBASE IV, 1.5 due to 'new'
- *-- behavior (see READ.ME that comes with 1.5). Should function
- *-- fine with 1.1 and 1.0. This change from David Love (DAVIDLOVE).
- *-- NOTE: NEW PARAMETER
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: IsUnique(<xValue>,"<cOrder>","<cField>")
- *-- Example.....: @5,5 SAY "SSN: " GET SSN PICTURE "999-99-9999";
- *-- valid required IsUnique(SSN, "SSN", "SSN");
- *-- message "Enter a new SSN";
- *-- error chr(7)+"SSN must be unique!"
- *-- Returns.....: .T./.F.
- *-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
- *-- cOrder = MDX Tag used to order the database. Must be set for
- *-- field being checked.
- *-- cField = field name for 'get'.
- *-------------------------------------------------------------------------------
-
- parameters xValue, cOrder, cField
- private nRecNo, nRecCnt, cSetNear, cSetDel, lIsDeleted, cSetOrder
- private lIsUnique
-
- nRecNo = recno() && store current record number
- nRecCnt = reccount() && count records in database
-
- if nRecCnt = 0 && empty database, cValue MUST be unique
- return .t.
- endif
-
- cSetNear = set('NEAR') && store status of NEAR flag
- set near off && set it off
- cSetDel = set('DELETE') && store status of DELETE
- set delete on && Delete must be ON for this to work
- lIsDeleted = deleted() && is current record deleted?
- delete && set delete flag for current record
- cSetOrder = order() && store current MDX tag
- set order to (cOrder) && set tag to that sent to function
-
- if seek(xValue) && does it exist already?
- lIsUnique = .f. && if so, it's not unique
- else && otherwise,
- lIsUnique = .t. && it is.
- endif
-
- set order to (cSetOrder) && restore changed settings to original settings
- set delete &cSetDel
- set near &cSetNear
-
- if nRecNo > nRecCnt && if called during an append
- go bottom && goto the bottom of the database,
- skip 1 && plus one record (the new one)
- if lIsUnique && this is the new part ...
- replace &cField with xValue
- endif
- else
- go nRecNo && otherwise, goto the current record number
- endif
-
- if .not. lIsDeleted && was record 'deleted' before?
- recall && if not, undelete it ... (turn flag off)
- endif
-
- RETURN (lIsUnique)
- *-- EoF: IsUnique()
-
- *===============================================================================
- * MISC ROUTINES -- Ones that don't fit into other categories, quite ... but
- * are none-the-less very useful ... many of these routines have been placed
- * in the library file: MISC.PRG.
- *===============================================================================
-
- PROCEDURE SetPrint
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 05/24/1991
- *-- Notes.......: Used to set the the appropriate default settings.
- *-- (Can be modified easily for other printers ...)
- *-- If you want "letter quality" print on some printers,
- *-- you can take the * out from the one line below. Note
- *-- that some printer drivers don't have a "letter quality" mode,
- *-- and dBASE will spit out an error message if you try to
- *-- force it (by using _pquality). I use this routine for
- *-- various systems, and only use _pquality for my dot matrix
- *-- at home. Change the printer driver below to the one you
- *-- are using. The _pdriver line only REALLY needs to be
- *-- in use on a LAN, where who knows what settings may have been
- *-- dumped into the printer in between the time you loaded dBASE
- *-- (and the printer driver) and the time you really want to
- *-- print?
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do setprint
- *-- Example.....: do setprint
- *-- Returns.....: None
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
- *_pdriver = "HPLAS2I" && printer driver
- _ppitch = "PICA" && printer pitch (10 CPI)
- _box = .t. && make sure we can print boxes/line draw
- _ploffset = 0 && page offset (left side) to 0
- _lmargin = 0 && left margin (also set to 0)
- _rmargin = 80 && right margin set to 80
- _plength = 66 && page length
- _peject = "NONE" && don't send extra blank pages . . .
- * _pquality = .t. && set print quality to high -- not available
- && for some printers (i.e., LaserJets)
-
- RETURN
- *-- EoP: SetPrint
-
- FUNCTION DosRun
- *-------------------------------------------------------------------------------
- *-- Programmer..: Michael P. Dean (Ashton-Tate)
- *-- Date........: 05/01/1992
- *-- Notes.......: A routine to run a DOS program, checks to see if a
- *-- window is active -- if so, it avoids the inevitable
- *-- "Press any key to continue" and the subsequent messing
- *-- up of the screen display.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: Pulled from A-T BBS
- *-- 05/13/1991 - modified by Ken Mayer to use the DBASE
- *-- RUN() function, rather than the ! or RUN commands.
- *-- (suggested by Clinton L. Warren (VBCES).)
- *-- Minor additions for screens from "Bosephus" on ATBBS 10/31/91
- *-- 12/14/1991 - modified by Jim Magnant (TXAGGIE) to deactivate
- *-- and reactivate up to 10 windows ...
- *-- 04/21/1992 -- Modified for dBASE IV, 1.5 to use memory
- *-- handling parameters (.t.,<command>,.t.) of RUN() function.
- *-- 05/01/1992 -- Modified to allow use with EITHER 1.1 or 1.5.
- *-- By calling VERSION() without a parm, the version of dBASE
- *-- or RUNTIME is the last three characters on the right.
- *-- Taking the VAL() of that, we can ask if the version is => 1.5
- *-- and process from there.
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: DosRun(<cCmd>)
- *-- Example.....: ndummy = dosrun("DIR /W /P")
- *-- * or
- *-- ndummy = dosrun(memvar) && where memvar contains dos
- *-- && command and parameters ...
- *-- Returns.....: Nul
- *-- Parameters..: cCmd = Command (and parameters) to be executed
- *-------------------------------------------------------------------------------
-
- parameter cCmd
- private aWindow, n, nRun
-
- save screen to sDOS && save screen ...
- n = 0 && set to 0 in case there are NO Windows active
- declare aWindow[10]
- aWindow[1] = window() && grab window name of current window
- if len(trim(aWindow[1])) > 0 && if there's a window, deactivate
- n = 1
- do while len(trim(aWindow[n])) > 0 && if there are more windows ...
- deactivate window &aWindow[n] && deactivate them, too ...
- n = n + 1
- aWindow[n] = window()
- enddo
- endif
- set console off && don't display to screen
- if val(right(version(),3)) => 1.5 && check version number. If > 1.5
- nRun = run(.t.,"&cCmd",.t.) && use complete swapping of dBASE, etc.
- else && else it's 1.1 or 1.0
- nRun = run("&cCmd") && use older version of RUN() function
- endif
- set console on && ok, display to screen
- n = n - 1 && compensate for final n=n+1 in prev.
- if len(trim(aWindow[1])) > 1 && if there's a window, reactivate
- do while n > 0 && all but last window
- activate window &aWindow[n] && activate
- n = n - 1 && decrement stack
- enddo
- activate window &aWindow[1] && activate final window ...
- endif
- restore screen from sDOS
- release screen sDOS
-
- RETURN ""
- *-- EoF: DosRun()
-
- FUNCTION ScrnRpt
- *-------------------------------------------------------------------------------
- *-- Programmer...: Bryan Flynn (AT/BOR-BBS)
- *-- Date.........: 10/31/91
- *-- Notes........: Used to display a dBASE Report on screen, allowing pauses
- *-- when the screen is full.
- *-- Written for..: dBASE IV, 1.1
- *-- Rev. History.: Changed by a lot of people to current version.
- *-- Calls........: None
- *-- Called by....: Any
- *-- Usage........: ?ScrnRpt("<cRpt cArg>")
- *-- Example......: ?ScrnRpt("FT_REP1 FOR PROB='HPEQUIP'")
- *-- Returns......: "" (Nul)
- *-- Parameters...: cRpt = Name of report with any arguments for command line
- *-------------------------------------------------------------------------------
-
- Parameter cRpt
- private lPWait, nPLength, cEscape
-
- *-- save system variables
- lPWait = _pwait
- nPLength = _plength
- cEscape = SET("ESCAPE")
- *-- set new variables
- _pwait = .t.
- _plength = iif("43" $ SET("DISPLAY"),40,25) && if EGA43, set to 40, else 25
- set escape on
-
- *-- store current screen
- save screen to sTemp
- clear
-
- *-- set printer to nowhere and generate report
- set printer to nul
- report form &cRpt noeject to print
-
- *-- set things back to normal
- set escape &cEscape
- set printer to LPT1
- wait
- clear
- restore screen from sTemp
- release screen sTemp
- _pwait = lPWait
- _plength = nPLength
-
- RETURN ""
- *-- EoF: ScrnRpt()
-
- FUNCTION IsMouse
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 06/18/1992
- *-- Notes.......: This is used to determine the presence of a mouse driver.
- *-- Returns a .t. if a mouse driver is detected, a .f. otherwise.
- *-- This routine will turn the mouse off, automatically. This
- *-- can be used to detect a mouse, and turn it off, as well
- *-- as to set a memvar to determine the current mouse state.
- *-- For example, after running this routine, the mouse will be
- *-- off (if there's a driver).
- *-- ******************************
- *-- **** REQUIRES JPMOUSE.BIN ****
- *-- ******************************
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: IsMouse()
- *-- Example.....: ?IsMouse()
- *-- Returns.....: Logical
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private cRetVal, lIsMouse, X
-
- Load JPMOUSE.BIN
- cRetVal = call("JPMOUSE","?")
- lIsMouse = iif(cRetVal="T",.t.,.f.)
- if lIsMouse
- x = call("JPMOUSE","H")
- endif
- release module JPMOUSE
-
- RETURN lIsMouse
- *-- EoF: IsMouse()
-
- PROCEDURE SetMouse
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 06/18/1992
- *-- Notes.......: This is used to determine the presence of a mouse driver,
- *-- and/or turn the mouse cursor off in dBASE IV, 1.5
- *-- ******************************
- *-- **** Requires JPMOUSE.BIN ****
- *-- ******************************
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: Do SetMouse with <c_Mouse>
- *-- Example.....: PUBLIC c_Mouse
- *-- x=ismouse() && function in MISC.PRG
- *-- store "OFF" to c_Mouse && after calling IsMouse() it's 'Off'
- *-- ON KEY LABEL Alt-M DO SetMouse
- *-- Returns.....: .T.
- *-- Parameters..: c_Mouse = A GLOBAL memory variable -- this can/will be changed
- *-- by this procedure to the opposite scenario when the
- *-- routine is called. The concept here is to switch
- *-- the mouse on and/or off if there's a mouse driver.
- *-- This memvar should be set to the current status of the mouse-
- *-- if on, it should hold "ON" in it ...
- *-------------------------------------------------------------------------------
-
- private X
-
- if type("C_MOUSE") # "C" && if c_Mouse has not been defined as
- return && a character field, return
- endif
-
- load JPMOUSE.BIN && load the module
-
- *-- if the mouse is off, we're going to set it on ("S"), if on, we're
- *-- going to set it off "H")
- cSetMouse = iif(upper(c_Mouse) = "OFF","S","H")
- x=call("JPMOUSE",cSetMouse)
-
- release module JPMOUSE && remove from memory
-
- *-- if c_Mouse was 'off' we are setting it 'on', and vice versa
- c_Mouse = iif(upper(c_Mouse) = "OFF","ON","OFF") && change state of c_Mouse
-
- RETURN
- *-- EoP: SetMouse
-
- FUNCTION SwitchLib
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 05/01/1992
- *-- Notes.......: Used with dBASE IV, 1.5 to switch LIBRARY files. It's designed
- *-- as a quick toggle between libraries. See example below.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: SwitchLib(<cNewLib>)
- *-- Example.....: cOldLib = SwitchLib("FILES")
- *-- *-- execute function/procedure needed
- *-- cOldLib = SwitchLib("&cOldLib")
- *-- Returns.....: Old Library setting
- *-- Parameters..: cNewLib = Library file you wish to change to. If the file
- *-- extension is not '.PRG', you should add the file
- *-- extension to the description (I.e, "FILES.LIB")
- *-------------------------------------------------------------------------------
-
- parameters cNewLib
- private cCurLib
-
- cCurLib = set("LIBRARY")
- set library to &cNewLib.
-
- RETURN cCurLib
- *-- EoF: SwitchLib()
-
- FUNCTION VerLevel
- *-------------------------------------------------------------------------------
- *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
- *-- Date........: 06-24-1992
- *-- Notes.......: Returns the numeric version number of the current version
- *-- of dBASE or RUNTIME. Useful in version specific routines.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: VerLevel()
- *-- Example.....: if VerLevel() >= 1.5
- *-- Returns.....: a numeric equivalent of Version()
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private cVersion, nPos
- cVersion = version()
- nPos = 1
- do while left(right(cVersion,nPos),1) # " "
- nPos = nPos + 1
- enddo
-
- RETURN val(right(cVersion,nPos+1))
- *-- Eof() VerLevel
-
- *===============================================================================
- *-- End of Procedure File -- PROC.PRG
- *===============================================================================